home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / lib / perl / 5.10.0 / Cwd.pm < prev    next >
Encoding:
Perl POD Document  |  2008-07-24  |  14.5 KB  |  570 lines
  1. package Cwd;
  2.  
  3. use strict;
  4. use Exporter;
  5. use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  6.  
  7. $VERSION = '3.2501';
  8.  
  9. @ISA = qw/ Exporter /;
  10. @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
  11. push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
  12. @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
  13.  
  14. # sys_cwd may keep the builtin command
  15.  
  16. # All the functionality of this module may provided by builtins,
  17. # there is no sense to process the rest of the file.
  18. # The best choice may be to have this in BEGIN, but how to return from BEGIN?
  19.  
  20. if ($^O eq 'os2') {
  21.     local $^W = 0;
  22.  
  23.     *cwd                = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
  24.     *getcwd             = \&cwd;
  25.     *fastgetcwd         = \&cwd;
  26.     *fastcwd            = \&cwd;
  27.  
  28.     *fast_abs_path      = \&sys_abspath if defined &sys_abspath;
  29.     *abs_path           = \&fast_abs_path;
  30.     *realpath           = \&fast_abs_path;
  31.     *fast_realpath      = \&fast_abs_path;
  32.  
  33.     return 1;
  34. }
  35.  
  36. # If loading the XS stuff doesn't work, we can fall back to pure perl
  37. eval {
  38.   if ( $] >= 5.006 ) {
  39.     require XSLoader;
  40.     XSLoader::load( __PACKAGE__, $VERSION );
  41.   } else {
  42.     require DynaLoader;
  43.     push @ISA, 'DynaLoader';
  44.     __PACKAGE__->bootstrap( $VERSION );
  45.   }
  46. };
  47.  
  48. # Must be after the DynaLoader stuff:
  49. $VERSION = eval $VERSION;
  50.  
  51. # Big nasty table of function aliases
  52. my %METHOD_MAP =
  53.   (
  54.    VMS =>
  55.    {
  56.     cwd            => '_vms_cwd',
  57.     getcwd        => '_vms_cwd',
  58.     fastcwd        => '_vms_cwd',
  59.     fastgetcwd        => '_vms_cwd',
  60.     abs_path        => '_vms_abs_path',
  61.     fast_abs_path    => '_vms_abs_path',
  62.    },
  63.  
  64.    MSWin32 =>
  65.    {
  66.     # We assume that &_NT_cwd is defined as an XSUB or in the core.
  67.     cwd            => '_NT_cwd',
  68.     getcwd        => '_NT_cwd',
  69.     fastcwd        => '_NT_cwd',
  70.     fastgetcwd        => '_NT_cwd',
  71.     abs_path        => 'fast_abs_path',
  72.     realpath        => 'fast_abs_path',
  73.    },
  74.  
  75.    dos => 
  76.    {
  77.     cwd            => '_dos_cwd',
  78.     getcwd        => '_dos_cwd',
  79.     fastgetcwd        => '_dos_cwd',
  80.     fastcwd        => '_dos_cwd',
  81.     abs_path        => 'fast_abs_path',
  82.    },
  83.  
  84.    qnx =>
  85.    {
  86.     cwd            => '_qnx_cwd',
  87.     getcwd        => '_qnx_cwd',
  88.     fastgetcwd        => '_qnx_cwd',
  89.     fastcwd        => '_qnx_cwd',
  90.     abs_path        => '_qnx_abs_path',
  91.     fast_abs_path    => '_qnx_abs_path',
  92.    },
  93.  
  94.    cygwin =>
  95.    {
  96.     getcwd        => 'cwd',
  97.     fastgetcwd        => 'cwd',
  98.     fastcwd        => 'cwd',
  99.     abs_path        => 'fast_abs_path',
  100.     realpath        => 'fast_abs_path',
  101.    },
  102.  
  103.    epoc =>
  104.    {
  105.     cwd            => '_epoc_cwd',
  106.     getcwd            => '_epoc_cwd',
  107.     fastgetcwd        => '_epoc_cwd',
  108.     fastcwd        => '_epoc_cwd',
  109.     abs_path        => 'fast_abs_path',
  110.    },
  111.  
  112.    MacOS =>
  113.    {
  114.     getcwd        => 'cwd',
  115.     fastgetcwd        => 'cwd',
  116.     fastcwd        => 'cwd',
  117.     abs_path        => 'fast_abs_path',
  118.    },
  119.   );
  120.  
  121. $METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
  122. $METHOD_MAP{nto} = $METHOD_MAP{qnx};
  123.  
  124. # Find the pwd command in the expected locations.  We assume these
  125. # are safe.  This prevents _backtick_pwd() consulting $ENV{PATH}
  126. # so everything works under taint mode.
  127. my $pwd_cmd;
  128. foreach my $try ('/bin/pwd',
  129.          '/usr/bin/pwd',
  130.          '/QOpenSys/bin/pwd', # OS/400 PASE.
  131.         ) {
  132.  
  133.     if( -x $try ) {
  134.         $pwd_cmd = $try;
  135.         last;
  136.     }
  137. }
  138. my $found_pwd_cmd = defined($pwd_cmd);
  139. unless ($pwd_cmd) {
  140.     # Isn't this wrong?  _backtick_pwd() will fail if somenone has
  141.     # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
  142.     # See [perl #16774]. --jhi
  143.     $pwd_cmd = 'pwd';
  144. }
  145.  
  146. # Lazy-load Carp
  147. sub _carp  { require Carp; Carp::carp(@_)  }
  148. sub _croak { require Carp; Carp::croak(@_) }
  149.  
  150. # The 'natural and safe form' for UNIX (pwd may be setuid root)
  151. sub _backtick_pwd {
  152.     # Localize %ENV entries in a way that won't create new hash keys
  153.     my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
  154.     local @ENV{@localize};
  155.     
  156.     my $cwd = `$pwd_cmd`;
  157.     # Belt-and-suspenders in case someone said "undef $/".
  158.     local $/ = "\n";
  159.     # `pwd` may fail e.g. if the disk is full
  160.     chomp($cwd) if defined $cwd;
  161.     $cwd;
  162. }
  163.  
  164. # Since some ports may predefine cwd internally (e.g., NT)
  165. # we take care not to override an existing definition for cwd().
  166.  
  167. unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
  168.     # The pwd command is not available in some chroot(2)'ed environments
  169.     my $sep = $Config::Config{path_sep} || ':';
  170.     my $os = $^O;  # Protect $^O from tainting
  171.  
  172.     # Try again to find a pwd, this time searching the whole PATH.
  173.     if (defined $ENV{PATH} and $os ne 'MSWin32') {  # no pwd on Windows
  174.     my @candidates = split($sep, $ENV{PATH});
  175.     while (!$found_pwd_cmd and @candidates) {
  176.         my $candidate = shift @candidates;
  177.         $found_pwd_cmd = 1 if -x "$candidate/pwd";
  178.     }
  179.     }
  180.  
  181.     # MacOS has some special magic to make `pwd` work.
  182.     if( $os eq 'MacOS' || $found_pwd_cmd )
  183.     {
  184.     *cwd = \&_backtick_pwd;
  185.     }
  186.     else {
  187.     *cwd = \&getcwd;
  188.     }
  189. }
  190.  
  191. if ($^O eq 'cygwin') {
  192.   # We need to make sure cwd() is called with no args, because it's
  193.   # got an arg-less prototype and will die if args are present.
  194.   local $^W = 0;
  195.   my $orig_cwd = \&cwd;
  196.   *cwd = sub { &$orig_cwd() }
  197. }
  198.  
  199. # set a reasonable (and very safe) default for fastgetcwd, in case it
  200. # isn't redefined later (20001212 rspier)
  201. *fastgetcwd = \&cwd;
  202.  
  203. # A non-XS version of getcwd() - also used to bootstrap the perl build
  204. # process, when miniperl is running and no XS loading happens.
  205. sub _perl_getcwd
  206. {
  207.     abs_path('.');
  208. }
  209.  
  210. # By John Bazik
  211. #
  212. # Usage: $cwd = &fastcwd;
  213. #
  214. # This is a faster version of getcwd.  It's also more dangerous because
  215. # you might chdir out of a directory that you can't chdir back into.
  216.     
  217. sub fastcwd_ {
  218.     my($odev, $oino, $cdev, $cino, $tdev, $tino);
  219.     my(@path, $path);
  220.     local(*DIR);
  221.  
  222.     my($orig_cdev, $orig_cino) = stat('.');
  223.     ($cdev, $cino) = ($orig_cdev, $orig_cino);
  224.     for (;;) {
  225.     my $direntry;
  226.     ($odev, $oino) = ($cdev, $cino);
  227.     CORE::chdir('..') || return undef;
  228.     ($cdev, $cino) = stat('.');
  229.     last if $odev == $cdev && $oino == $cino;
  230.     opendir(DIR, '.') || return undef;
  231.     for (;;) {
  232.         $direntry = readdir(DIR);
  233.         last unless defined $direntry;
  234.         next if $direntry eq '.';
  235.         next if $direntry eq '..';
  236.  
  237.         ($tdev, $tino) = lstat($direntry);
  238.         last unless $tdev != $odev || $tino != $oino;
  239.     }
  240.     closedir(DIR);
  241.     return undef unless defined $direntry; # should never happen
  242.     unshift(@path, $direntry);
  243.     }
  244.     $path = '/' . join('/', @path);
  245.     if ($^O eq 'apollo') { $path = "/".$path; }
  246.     # At this point $path may be tainted (if tainting) and chdir would fail.
  247.     # Untaint it then check that we landed where we started.
  248.     $path =~ /^(.*)\z/s        # untaint
  249.     && CORE::chdir($1) or return undef;
  250.     ($cdev, $cino) = stat('.');
  251.     die "Unstable directory path, current directory changed unexpectedly"
  252.     if $cdev != $orig_cdev || $cino != $orig_cino;
  253.     $path;
  254. }
  255. if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
  256.  
  257. # Keeps track of current working directory in PWD environment var
  258. # Usage:
  259. #    use Cwd 'chdir';
  260. #    chdir $newdir;
  261.  
  262. my $chdir_init = 0;
  263.  
  264. sub chdir_init {
  265.     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
  266.     my($dd,$di) = stat('.');
  267.     my($pd,$pi) = stat($ENV{'PWD'});
  268.     if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
  269.         $ENV{'PWD'} = cwd();
  270.     }
  271.     }
  272.     else {
  273.     my $wd = cwd();
  274.     $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
  275.     $ENV{'PWD'} = $wd;
  276.     }
  277.     # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
  278.     if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
  279.     my($pd,$pi) = stat($2);
  280.     my($dd,$di) = stat($1);
  281.     if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
  282.         $ENV{'PWD'}="$2$3";
  283.     }
  284.     }
  285.     $chdir_init = 1;
  286. }
  287.  
  288. sub chdir {
  289.     my $newdir = @_ ? shift : '';    # allow for no arg (chdir to HOME dir)
  290.     $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
  291.     chdir_init() unless $chdir_init;
  292.     my $newpwd;
  293.     if ($^O eq 'MSWin32') {
  294.     # get the full path name *before* the chdir()
  295.     $newpwd = Win32::GetFullPathName($newdir);
  296.     }
  297.  
  298.     return 0 unless CORE::chdir $newdir;
  299.  
  300.     if ($^O eq 'VMS') {
  301.     return $ENV{'PWD'} = $ENV{'DEFAULT'}
  302.     }
  303.     elsif ($^O eq 'MacOS') {
  304.     return $ENV{'PWD'} = cwd();
  305.     }
  306.     elsif ($^O eq 'MSWin32') {
  307.     $ENV{'PWD'} = $newpwd;
  308.     return 1;
  309.     }
  310.  
  311.     if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
  312.     $ENV{'PWD'} = cwd();
  313.     } elsif ($newdir =~ m#^/#s) {
  314.     $ENV{'PWD'} = $newdir;
  315.     } else {
  316.     my @curdir = split(m#/#,$ENV{'PWD'});
  317.     @curdir = ('') unless @curdir;
  318.     my $component;
  319.     foreach $component (split(m#/#, $newdir)) {
  320.         next if $component eq '.';
  321.         pop(@curdir),next if $component eq '..';
  322.         push(@curdir,$component);
  323.     }
  324.     $ENV{'PWD'} = join('/',@curdir) || '/';
  325.     }
  326.     1;
  327. }
  328.  
  329. sub _perl_abs_path
  330. {
  331.     my $start = @_ ? shift : '.';
  332.     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
  333.  
  334.     unless (@cst = stat( $start ))
  335.     {
  336.     _carp("stat($start): $!");
  337.     return '';
  338.     }
  339.  
  340.     unless (-d _) {
  341.         # Make sure we can be invoked on plain files, not just directories.
  342.         # NOTE that this routine assumes that '/' is the only directory separator.
  343.     
  344.         my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
  345.         or return cwd() . '/' . $start;
  346.     
  347.     # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
  348.     if (-l $start) {
  349.         my $link_target = readlink($start);
  350.         die "Can't resolve link $start: $!" unless defined $link_target;
  351.         
  352.         require File::Spec;
  353.             $link_target = $dir . '/' . $link_target
  354.                 unless File::Spec->file_name_is_absolute($link_target);
  355.         
  356.         return abs_path($link_target);
  357.     }
  358.     
  359.     return $dir ? abs_path($dir) . "/$file" : "/$file";
  360.     }
  361.  
  362.     $cwd = '';
  363.     $dotdots = $start;
  364.     do
  365.     {
  366.     $dotdots .= '/..';
  367.     @pst = @cst;
  368.     local *PARENT;
  369.     unless (opendir(PARENT, $dotdots))
  370.     {
  371.         _carp("opendir($dotdots): $!");
  372.         return '';
  373.     }
  374.     unless (@cst = stat($dotdots))
  375.     {
  376.         _carp("stat($dotdots): $!");
  377.         closedir(PARENT);
  378.         return '';
  379.     }
  380.     if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
  381.     {
  382.         $dir = undef;
  383.     }
  384.     else
  385.     {
  386.         do
  387.         {
  388.         unless (defined ($dir = readdir(PARENT)))
  389.             {
  390.             _carp("readdir($dotdots): $!");
  391.             closedir(PARENT);
  392.             return '';
  393.         }
  394.         $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
  395.         }
  396.         while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
  397.            $tst[1] != $pst[1]);
  398.     }
  399.     $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
  400.     closedir(PARENT);
  401.     } while (defined $dir);
  402.     chop($cwd) unless $cwd eq '/'; # drop the trailing /
  403.     $cwd;
  404. }
  405.  
  406. my $Curdir;
  407. sub fast_abs_path {
  408.     local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
  409.     my $cwd = getcwd();
  410.     require File::Spec;
  411.     my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
  412.  
  413.     # Detaint else we'll explode in taint mode.  This is safe because
  414.     # we're not doing anything dangerous with it.
  415.     ($path) = $path =~ /(.*)/;
  416.     ($cwd)  = $cwd  =~ /(.*)/;
  417.  
  418.     unless (-e $path) {
  419.      _croak("$path: No such file or directory");
  420.     }
  421.  
  422.     unless (-d _) {
  423.         # Make sure we can be invoked on plain files, not just directories.
  424.     
  425.     my ($vol, $dir, $file) = File::Spec->splitpath($path);
  426.     return File::Spec->catfile($cwd, $path) unless length $dir;
  427.  
  428.     if (-l $path) {
  429.         my $link_target = readlink($path);
  430.         die "Can't resolve link $path: $!" unless defined $link_target;
  431.         
  432.         $link_target = File::Spec->catpath($vol, $dir, $link_target)
  433.                 unless File::Spec->file_name_is_absolute($link_target);
  434.         
  435.         return fast_abs_path($link_target);
  436.     }
  437.     
  438.     return $dir eq File::Spec->rootdir
  439.       ? File::Spec->catpath($vol, $dir, $file)
  440.       : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
  441.     }
  442.  
  443.     if (!CORE::chdir($path)) {
  444.      _croak("Cannot chdir to $path: $!");
  445.     }
  446.     my $realpath = getcwd();
  447.     if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
  448.      _croak("Cannot chdir back to $cwd: $!");
  449.     }
  450.     $realpath;
  451. }
  452.  
  453. # added function alias to follow principle of least surprise
  454. # based on previous aliasing.  --tchrist 27-Jan-00
  455. *fast_realpath = \&fast_abs_path;
  456.  
  457. # --- PORTING SECTION ---
  458.  
  459. # VMS: $ENV{'DEFAULT'} points to default directory at all times
  460. # 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
  461. # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
  462. #   in the process logical name table as the default device and directory
  463. #   seen by Perl. This may not be the same as the default device
  464. #   and directory seen by DCL after Perl exits, since the effects
  465. #   the CRTL chdir() function persist only until Perl exits.
  466.  
  467. sub _vms_cwd {
  468.     return $ENV{'DEFAULT'};
  469. }
  470.  
  471. sub _vms_abs_path {
  472.     return $ENV{'DEFAULT'} unless @_;
  473.     my $path = shift;
  474.  
  475.     if (-l $path) {
  476.         my $link_target = readlink($path);
  477.         die "Can't resolve link $path: $!" unless defined $link_target;
  478.         
  479.         return _vms_abs_path($link_target);
  480.     }
  481.  
  482.     # may need to turn foo.dir into [.foo]
  483.     my $pathified = VMS::Filespec::pathify($path);
  484.     $path = $pathified if defined $pathified;
  485.     
  486.     return VMS::Filespec::rmsexpand($path);
  487. }
  488.  
  489. sub _os2_cwd {
  490.     $ENV{'PWD'} = `cmd /c cd`;
  491.     chomp $ENV{'PWD'};
  492.     $ENV{'PWD'} =~ s:\\:/:g ;
  493.     return $ENV{'PWD'};
  494. }
  495.  
  496. sub _win32_cwd {
  497.     if (defined &DynaLoader::boot_DynaLoader) {
  498.     $ENV{'PWD'} = Win32::GetCwd();
  499.     }
  500.     else { # miniperl
  501.     chomp($ENV{'PWD'} = `cd`);
  502.     }
  503.     $ENV{'PWD'} =~ s:\\:/:g ;
  504.     return $ENV{'PWD'};
  505. }
  506.  
  507. *_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd;
  508.  
  509. sub _dos_cwd {
  510.     if (!defined &Dos::GetCwd) {
  511.         $ENV{'PWD'} = `command /c cd`;
  512.         chomp $ENV{'PWD'};
  513.         $ENV{'PWD'} =~ s:\\:/:g ;
  514.     } else {
  515.         $ENV{'PWD'} = Dos::GetCwd();
  516.     }
  517.     return $ENV{'PWD'};
  518. }
  519.  
  520. sub _qnx_cwd {
  521.     local $ENV{PATH} = '';
  522.     local $ENV{CDPATH} = '';
  523.     local $ENV{ENV} = '';
  524.     $ENV{'PWD'} = `/usr/bin/fullpath -t`;
  525.     chomp $ENV{'PWD'};
  526.     return $ENV{'PWD'};
  527. }
  528.  
  529. sub _qnx_abs_path {
  530.     local $ENV{PATH} = '';
  531.     local $ENV{CDPATH} = '';
  532.     local $ENV{ENV} = '';
  533.     my $path = @_ ? shift : '.';
  534.     local *REALPATH;
  535.  
  536.     defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
  537.       die "Can't open /usr/bin/fullpath: $!";
  538.     my $realpath = <REALPATH>;
  539.     close REALPATH;
  540.     chomp $realpath;
  541.     return $realpath;
  542. }
  543.  
  544. sub _epoc_cwd {
  545.     $ENV{'PWD'} = EPOC::getcwd();
  546.     return $ENV{'PWD'};
  547. }
  548.  
  549. # Now that all the base-level functions are set up, alias the
  550. # user-level functions to the right places
  551.  
  552. if (exists $METHOD_MAP{$^O}) {
  553.   my $map = $METHOD_MAP{$^O};
  554.   foreach my $name (keys %$map) {
  555.     local $^W = 0;  # assignments trigger 'subroutine redefined' warning
  556.     no strict 'refs';
  557.     *{$name} = \&{$map->{$name}};
  558.   }
  559. }
  560.  
  561. # In case the XS version doesn't load.
  562. *abs_path = \&_perl_abs_path unless defined &abs_path;
  563. *getcwd = \&_perl_getcwd unless defined &getcwd;
  564.  
  565. # added function alias for those of us more
  566. # used to the libc function.  --tchrist 27-Jan-00
  567. *realpath = \&abs_path;
  568.  
  569. 1;
  570.